home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 05 - 1989 / 05.01 Jan 89 / forth stuff / Queues < prev    next >
Encoding:
Text File  |  1988-11-21  |  8.6 KB  |  467 lines  |  [TEXT/MACH]
  1. \ mini task to display system queues
  2. \ © 1988 J. Langowski / MacTutor
  3.  
  4. only forth also assembler also mac
  5.  
  6. $160 constant vblqhdr
  7. $356 constant vcbqhdr
  8. $308 constant drvqhdr
  9. $14a constant evtqhdr
  10. $360 constant fsqhdr
  11. $d92 constant dtqhdr
  12. $b30 constant timevars
  13. $11c constant utablebase
  14.  
  15.  72 user taskwindowpointer
  16.  92 user (type)
  17. 108 user taskmenubar
  18. 144 user uservector
  19. 148 user userdata
  20. 152 user content-hook
  21. 164 user goaway-hook
  22. 168 user update-hook
  23. 172 user activate-hook
  24.  
  25.  2 CONSTANT Message
  26. 10 CONSTANT Where
  27. 14 CONSTANT Modifiers
  28.  1 CONSTANT ActivateMask
  29.  
  30. 300 constant appleid
  31. 301 constant fileid
  32. 302 constant editid
  33.  
  34. 152 CONSTANT WrefCon
  35.  
  36. create rect1 20 w, 20 w, 90 w, 28 w,
  37. create rect2 20 w, 35 w, 90 w, 43 w,
  38. create rect3 20 w, 50 w, 90 w, 58 w,
  39. create rect4 20 w, 65 w, 90 w, 73 w,
  40. create rect5 20 w, 80 w, 90 w, 88 w,
  41. create rect6 20 w, 95 w, 90 w, 103 w,
  42. create rect7 20 w, 110 w, 90 w, 118 w,
  43.  
  44. CREATE APPLESTRING  01 C,  $14 C, 
  45.  
  46. NEW.MBAR queueBar
  47.  
  48. NEW.MENU AppleMenu
  49. APPLESTRING AppleMenu TITLE
  50. 0 APPLEID AppleMenu BOUNDS
  51. " About Queues ...;(-" AppleMenu ITEMS
  52.  
  53. NEW.MENU FileMenu
  54. " File" FileMenu TITLE
  55. 0 FileID FileMenu BOUNDS
  56. " Quit"    FileMenu ITEMS
  57.  
  58. NEW.MENU EditMenu
  59. " Edit" EditMenu TITLE
  60. 0 EDITID EditMenu BOUNDS
  61. " (Undo/Z;(-;(Cut/K;(Copy/C;(Paste/V;(Clear" EditMenu ITEMS
  62.  
  63. NEW.MENU vblmenu
  64. " vbl" vblmenu TITLE
  65. -1 150 vblmenu BOUNDS
  66. " VBL Tasks;(-" vblmenu ITEMS
  67.  
  68. NEW.MENU vcbmenu
  69. " vcb" vcbmenu TITLE
  70. -1 151 vcbmenu BOUNDS
  71. " Vol contrl blks;(-" vcbmenu ITEMS
  72.  
  73. NEW.MENU drvmenu
  74. " drv" drvmenu TITLE
  75. -1 152 drvmenu BOUNDS
  76. " Drives;(-" drvmenu ITEMS
  77.  
  78. NEW.MENU evtmenu
  79. " evt" evtmenu TITLE
  80. -1 153 evtmenu BOUNDS
  81. " Events [???];(-" evtmenu ITEMS
  82.  
  83. NEW.MENU fsmenu
  84. " fs" fsmenu TITLE
  85. -1 154 fsmenu BOUNDS
  86. " File System;(-" fsmenu ITEMS
  87.  
  88. NEW.MENU dtmenu
  89. " dt" dtmenu TITLE
  90. -1 155 dtmenu BOUNDS
  91. " Def Tasks;(-" dtmenu ITEMS
  92.  
  93. NEW.MENU tmmenu
  94. " tm" tmmenu TITLE
  95. -1 156 tmmenu BOUNDS
  96. " Time manager;(-" tmmenu ITEMS
  97.  
  98. NEW.WINDOW SysQueue
  99. " System Queues" SysQueue TITLE
  100. 250 50 350 250 SysQueue BOUNDS
  101. Rounded Visible CloseBox GrowBox SysQueue ITEMS
  102.  
  103. NEW.WINDOW qInfo
  104. " Queue Info" qInfo TITLE
  105. 50 50 250 500 qInfo BOUNDS
  106. NoGrow Invisible NoCloseBox NoGrowBox qInfo ITEMS
  107.  
  108. 500 2000 terminal queues
  109.  
  110. CODE unpack
  111.     MOVE.L (A6),D0
  112.     CLR.L     D1
  113.     MOVE.W D0,D1
  114.     CLR.W  D0
  115.     SWAP.W D0
  116.     MOVE.L D0,(A6)
  117.     MOVE.L D1,-(A6)
  118.     RTS
  119. END-CODE MACH
  120.  
  121. : beep ( n )
  122.     0 do 1 call sysbeep loop 
  123. ;
  124.  
  125. : wait { #ticks | time -- }
  126.     call tickcount #ticks + -> time
  127.     begin pause
  128.         call tickcount time > 
  129.     until
  130. ;
  131.  
  132. : popup.select { menu pt | point -- menuID item# }
  133.     pt -> point 
  134.     ^ point call localtoglobal 
  135.     menu @ point unpack 1
  136.         call popupmenuselect
  137.     unpack
  138. ;
  139.  
  140. : do.content  {  | pt --  }
  141.     CALL FrontWindow CALL SetPort
  142.     qInfo call HideWindow
  143.     
  144.     RUN-CONTENT
  145.     EVENT-RECORD Where + @ -> pt
  146.     ^ pt CALL GlobalToLocal
  147.  
  148.     0
  149.     pt rect1 CALL PtInRect
  150.         IF drop vblmenu THEN
  151.     pt rect2 CALL PtInRect
  152.         IF drop vcbmenu THEN
  153.     pt rect3 CALL PtInRect
  154.         IF drop drvmenu THEN
  155.     pt rect4 CALL PtInRect
  156.         IF drop evtmenu THEN
  157.     pt rect5 CALL PtInRect
  158.         IF drop  fsmenu THEN
  159.     pt rect6 CALL PtInRect
  160.         IF drop  dtmenu THEN
  161.     pt rect7 CALL PtInRect
  162.         IF drop  tmmenu THEN
  163.     
  164.     ?dup IF ( rectangle was selected)
  165.         pt popup.select 
  166.  
  167.         IF     ( popup selection was made )
  168.         ( menuID ) userData task-> queues !
  169.         THEN
  170.     THEN
  171. ;
  172.     
  173. : draw.rects
  174.     rect1 call framerect
  175.     rect2 call framerect
  176.     rect3 call framerect
  177.     rect4 call framerect
  178.     rect5 call framerect
  179.     rect6 call framerect
  180.     rect7 call framerect
  181. ;
  182.  
  183. : clr.rects
  184.     rect1 call eraserect
  185.     rect2 call eraserect
  186.     rect3 call eraserect
  187.     rect4 call eraserect
  188.     rect5 call eraserect
  189.     rect6 call eraserect
  190.     rect7 call eraserect
  191. ;
  192.  
  193. : blackBar { rect pixels | locBR locTL }
  194.     rect ^ locTL 8 cmove
  195.     ^ locBR w@ ( bottom ) pixels -
  196.     ^ locTL w!
  197.     ^ locTL call paintrect
  198. ;
  199.  
  200. : #elems { qhdr | elems -- #.of.queue.elements }
  201.     0 -> elems
  202.     2 +> qhdr
  203.     begin
  204.         qhdr @ ?dup while
  205.             -> qhdr
  206.         1 +> elems
  207.     repeat
  208.     elems
  209. ;
  210.     
  211. : display.queues {  | -- }
  212.     clr.rects
  213.     draw.rects
  214.     rect1 vblqhdr #elems 4* blackBar
  215.     rect2 vcbqhdr #elems 4* blackBar
  216.     rect3 drvqhdr #elems 4* blackBar
  217.     rect4 evtqhdr #elems 4* blackBar
  218.     rect5  fsqhdr #elems 4* blackBar
  219.     rect6  dtqhdr #elems 4* blackBar
  220.     rect7 timevars @ 8 + #elems 4* blackBar
  221. ;
  222.  
  223. : dsp.vbl { | qelemPtr n -- }
  224.     cls
  225.     qinfo " Vertical Blanking Tasks" 
  226.         call SetWTitle
  227.     ." ————————————————————————————————" cr
  228.     ." task# qtype  ProcPtr Count Phase" cr
  229.     ." ————————————————————————————————" cr
  230.     vblqhdr 2+ -> qelemptr
  231.     1 -> n
  232.     begin
  233.         qelemptr @ ?dup while
  234.         -> qelemptr
  235.         n 3 .r 3 spaces 
  236.         hex
  237.         qelemptr 4 + w@ 5 .r space
  238.         qelemptr 6 + @ 8 .r space
  239.         qelemptr 10 + w@ 5 .r space
  240.         qelemptr 12 + w@ 5 .r cr
  241.         decimal
  242.         1 +> n 
  243.     repeat
  244. ;
  245.  
  246. : dsp.vcb { | qelemPtr n -- }
  247.     cls
  248.     qinfo " Volume Control Blocks" 
  249.         call SetWTitle
  250.     ." —————————————————————————————————————————————————————————————————————————" cr
  251.     ."  vcb# qtype Volume name                Drive dRef# vRef# #blks blksz free" cr
  252.     ." —————————————————————————————————————————————————————————————————————————" cr
  253.     vcbqhdr 2+ -> qelemptr
  254.     1 -> n
  255.     begin
  256.         qelemptr @ ?dup while
  257.         -> qelemptr
  258.         n 3 .r 3 spaces 
  259.         hex
  260.         qelemptr 4 + w@ 5 .r space
  261.         qelemptr 44 + count dup rot swap type
  262.                                 27 swap - spaces
  263.         qelemptr 72 + w@ 5 .r space
  264.         qelemptr 74 + w@ 5 .r space
  265.         qelemptr 78 + w@ 5 .r space
  266.         qelemptr 26 + w@ 5 .r space
  267.         qelemptr 28 +  @ 5 .r space 
  268.         qelemptr 42 + w@ 4 .r cr
  269.         decimal
  270.         1 +> n 
  271.     repeat
  272. ;
  273.  
  274. : dsp.drv { | qelemPtr n -- }
  275.     cls
  276.     qinfo " Drives" 
  277.         call SetWTitle
  278.     ." —————————————————————————————————————————————" cr
  279.     ."  drv# qtype Drive dRef# FSID    #blks l dd ss" cr
  280.     ." —————————————————————————————————————————————" cr
  281.     drvqhdr 2+ -> qelemptr
  282.     1 -> n
  283.     begin
  284.         qelemptr @ ?dup while
  285.         -> qelemptr
  286.         n 3 .r 3 spaces 
  287.         hex
  288.         qelemptr 4 + w@ 5 .r space
  289.         qelemptr 6 + w@ 5 .r space
  290.         qelemptr 8 + w@ 5 .r space
  291.         qelemptr 10 + w@ 4 .r space
  292.         qelemptr 12 + w@
  293.         qelemptr 4 + w@ 1 = IF 
  294.             qelemptr 14 + w@ 65536 * + 
  295.         THEN
  296.             8 .r space
  297.         qelemptr 4- c@ $80 AND 
  298.         IF ascii y emit ELSE ascii n emit THEN space
  299.         qelemptr 3- c@ 2 .r 2 spaces 
  300.         qelemptr 1- c@ $80 AND 
  301.         IF ascii n emit ELSE ascii y emit THEN cr
  302.         decimal
  303.         1 +> n 
  304.     repeat
  305. ;
  306.  
  307. : dsp.evt { | qelemPtr n -- }
  308.     cls
  309.     qinfo " Queued Events" 
  310.         call SetWTitle
  311.     ." ————————————————————————————————————————————————" cr
  312.     ."  drv# qtype What  Message   When     Where  Mods" cr
  313.     ." ————————————————————————————————————————————————" cr
  314.     evtqhdr 2+ -> qelemptr
  315.     1 -> n
  316.     begin
  317.         qelemptr @ ?dup while
  318.         -> qelemptr
  319.         n 3 .r 3 spaces 
  320.         hex
  321.         qelemptr 4 + w@ 5 .r space
  322.         qelemptr 6 + w@ 5 .r space
  323.         qelemptr 8 +  @ 8 .r space
  324.         qelemptr 12 + @ 8 .r space
  325.         qelemptr 16 + @ 8 .r space
  326.         qelemptr 20 + w@ 4 .r cr
  327.         decimal
  328.         1 +> n 
  329.     repeat
  330. ;
  331.  
  332. : dsp.fs 
  333.     cls
  334.     qinfo " File System Requests" 
  335.         call SetWTitle
  336. ;
  337.  
  338. : dsp.dt
  339.     cls
  340.     qinfo " Deferred Tasks"
  341.         call SetWTitle
  342. ;
  343.         
  344. : dsp.tm { | qelemPtr n -- }
  345.     cls
  346.     qinfo " Time manager"
  347.         call SetWTitle
  348.     ." ——————————————————————————" cr
  349.     ." task# qtype  ProcPtr Count" cr
  350.     ." ——————————————————————————" cr
  351.     timeVars @ 10 + -> qelemptr
  352.     1 -> n
  353.     begin
  354.         qelemptr @ ?dup while
  355.         -> qelemptr
  356.         n 3 .r 3 spaces 
  357.         hex
  358.         qelemptr 4 + w@ 5 .r space
  359.         qelemptr 6 +  @ 8 .r space
  360.         qelemptr 10 + w@ 5 .r cr
  361.         decimal
  362.         1 +> n 
  363.     repeat
  364. ;
  365.  
  366. : do.user
  367.         qInfo dup call showwindow call selectwindow
  368.         qInfo taskwindowpointer !
  369.         ( menuID ) CASE
  370.         150 OF    dsp.vbl ENDOF
  371.         151 OF  dsp.vcb ENDOF
  372.         152 OF    dsp.drv ENDOF
  373.         153 OF  dsp.evt ENDOF
  374.         154 OF    dsp.fs  ENDOF
  375.         155 OF  dsp.dt  ENDOF
  376.         156 OF  dsp.tm  ENDOF
  377.         ENDCASE
  378.         SysQueue taskwindowpointer !
  379. ;
  380.  
  381. : do.update  {  | pt  --  }
  382.     sysQueue call setport
  383.     draw.rects
  384.     run-update
  385. ;
  386.  
  387. : do.activate
  388.     event-record modifiers + w@ 
  389.     1 AND             \ Activate event?
  390.     IF     
  391.         call DrawMenuBar
  392.     ELSE
  393.     THEN 
  394. ;
  395.  
  396. : do.close
  397.     bye
  398. ;
  399.  
  400. : INIT-MBAR
  401.     queueBar ADD
  402.     queueBar APPLEMENU ADD        
  403.     APPLEMENU @ ascii DRVR  CALL ADDRESMENU 
  404.     queueBar FileMenu  ADD
  405.     queueBar EditMenu  ADD    
  406.     queueBar vblmenu add
  407.     queueBar vcbmenu add
  408.     queueBar drvmenu add
  409.     queueBar evtmenu add
  410.     queueBar fsmenu add
  411.     queueBar dtmenu add
  412.     queueBar tmmenu add
  413. ;
  414.  
  415. : DO-APPLE   { item# | [ 32 lallot ] daName -- }
  416.     item# 1 =                     
  417.     IF    3 beep
  418.  
  419.     ELSE    AppleMenu @
  420.             item# ^ DAName CALL GetItem
  421.         ^ DAName CALL OpenDeskAcc DROP
  422.     THEN 
  423. ;
  424.  
  425. : do-file
  426.     drop bye
  427. ;
  428.  
  429. : MBAR-HANDLER  ( item# menuID -  )    
  430.     CASE
  431.     APPLEID OF DO-APPLE      ENDOF
  432.     FILEID OF DO-FILE      ENDOF
  433.     drop
  434.     ENDCASE  
  435.     0 CALL HILITEMENU  
  436. ;
  437.  
  438. : go.queue { | mb -- }
  439.     activate
  440.  
  441.     ['] do.content content-hook !
  442.     ['] do.update update-hook ! 
  443.     ['] mbar-handler menu-vector !
  444.     ['] do.activate activate-hook !
  445.     ['] do.close goaway-hook !
  446.     ['] do.user uservector !
  447.  
  448.     begin
  449.         pause
  450.         sysQueue call setport
  451.         display.queues
  452.         60 wait
  453.     again
  454. ;
  455.  
  456. : start
  457.     SysQueue add
  458.     QInfo add
  459.     SysQueue queues build
  460.     SysQueue WRefCon + @
  461.     QInfo WRefCon + !
  462.     SysQueue dup call selectwindow call setport
  463.     init-mbar
  464.     queueBar queues mbar>task
  465.     queues go.queue
  466. ;
  467.